Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue31/extend/ODSXP.PAS

Pascal/Delphi Source File | 1997-07-03 | 19.6 KB | 730 lines

{ Created: 1997-02-14 by Berend  (c) 1997 by ASC

Unit which makes implementing SQL Server extended stored
procedures a breeze.

$Revision: 3 $


How to create an extended stored procedure:
1. Create a new class based TSQLXProc and override its
   Execute method.

2. Always create the following prototype

     function xp_demo(srvproc: PSRV_PROC): SRVRETCODE;
     var
       xp: TSQLXProc;
     begin
       xp := TMySQLXProc.Create(srvproc, ExpectedParams);
       Result := xp.Run;
       xp.Free;
     end;

3. export xp_demo.


Notes:
- lots of api calls not supported, but most of them you
  don't need for extended stored procedures. The few that
  remain are easy to add.
- don't trust my money datatype... I'm not sure the 8 byte
  calculations are done corretly (they seem to be, but you
  never know)
- numeric datatype only supported upto a nine digit precision
  (that is including the fractional part) so largest value
  is 999,999,999,0
- not supported datatypes: binary, varbinary, timestamp,
  text/image



$History: Odsxp.pas $
 *
 * *****************  Version 3  *****************
 * User: Berend       Date: 97-04-24   Time: 21:25
 * Updated in $/ASC sources
 * Fix bug: error is returned when ok and vice versa
 *
 * *****************  Version 1  *****************
 * User: Berend       Date: 97-02-18   Time: 20:06
 * Created in $/ASC sources
 * Extended procedures for Delphi
}


{$LONGSTRINGS ON}


unit Odsxp;

interface

uses
  Windows,
  SysUtils,
  Classes;


{ type definitions }
type
  Int8 = shortint;
  UInt8 = byte;
  Int16 = smallint;
  Int32 = longint;
  UInt16 = word;
  UInt32 = longint;



{ translated parts from Srv*.h }

const
  SUCCEED = 0;          { Successful return value   }
  FAIL = 1;             { Unsuccessful return value }

type
  SRVRETCODE = Int32;        { SUCCEED or FAIL }

const
  SRV_NULLTERM = -1;    { Indicates a null terminated string }

{  Done packet status fields. }
const
  SRV_DONE_FINAL        = $0000;
  SRV_DONE_MORE         = $0001;
  SRV_DONE_ERROR        = $0002;
  SRV_DONE_INXACT       = $0004;
  SRV_DONE_PROC         = $0008;
  SRV_DONE_COUNT        = $0010;
  SRV_DONE_ATTN         = $0020;
  SRV_DONE_RPC_IN_BATCH = $0080;


type
  PSRV_PROC = pointer;

{  Message types }
const
  SRV_MSG_INFO = 1;
  SRV_MSG_ERROR = 2;

{ define srv_symbol() SRV_ERRORs }
const
  SRV_ENO_OS_ERR = 0;
  SRV_INFO = 1;
  SRV_FATAL_PROCESS = 10;
  SRV_FATAL_SERVER = 19;

{  TDS tokens }
const
  SRV_TDS_NULL         = $1f;     { Null parameter from server }
  SRV_TDS_IMAGE        = $22;
  SRV_TDS_TEXT         = $23;
  SRV_TDS_VARBINARY    = $25;
  SRV_TDS_INTN         = $26;
  SRV_TDS_VARCHAR      = $27;
  SRV_TDS_BINARY       = $2d;
  SRV_TDS_CHAR         = $2f;
  SRV_TDS_INT1         = $30;
  SRV_TDS_BIT          = $32;
  SRV_TDS_INT2         = $34;
  SRV_TDS_DECIMAL      = $37;
  SRV_TDS_INT4         = $38;
  SRV_TDS_DATETIM4     = $3a;
  SRV_TDS_FLT4         = $3b;
  SRV_TDS_MONEY        = $3c;
  SRV_TDS_DATETIME     = $3d;
  SRV_TDS_FLT8         = $3e;
  SRV_TDS_NUMERIC      = $3f;
  SRV_TDS_DECIMALN     = $6a;
  SRV_TDS_NUMERICN     = $6c;
  SRV_TDS_FLTN         = $6d;
  SRV_TDS_MONEYN       = $6e;
  SRV_TDS_DATETIMN     = $6f;
  SRV_TDS_OFFSET       = $78;
  SRV_TDS_RETURNSTATUS = $79;
  SRV_TDS_MONEY4       = $7a;
  SRV_TDS_PROCID       = $7c;
  SRV_TDS_COLNAME      = $a0;
  SRV_TDS_COLFMT       = $a1;
  SRV_TDS_TABNAME      = $a4;
  SRV_TDS_COLINFO      = $a5;
  SRV_TDS_ORDER        = $a9;
  SRV_TDS_ERROR        = $aa;
  SRV_TDS_INFO         = $ab;
  SRV_TDS_RETURNVALUE  = $ac;
  SRV_TDS_LOGIN        = $ad;
  SRV_TDS_CONTROL      = $ae;
  SRV_TDS_ROW          = $d1;
  SRV_TDS_ENVCHANGE    = $e3;
  SRV_TDS_DONE         = $fd;
  SRV_TDS_DONEPROC     = $fe;
  SRV_TDS_DONEINPROC   = $ff;

{ server types }
const
  SRVNULL              = SRV_TDS_NULL; { Null parameter from server }
  SRVIMAGE             = SRV_TDS_IMAGE;
  SRVTEXT              = SRV_TDS_TEXT;
  SRVVARBINARY         = SRV_TDS_VARBINARY;
  SRVINTN              = SRV_TDS_INTN;
  SRVVARCHAR           = SRV_TDS_VARCHAR;
  SRVBINARY            = SRV_TDS_BINARY;
  SRVCHAR              = SRV_TDS_CHAR;
  SRVINT1              = SRV_TDS_INT1;
  SRVBIT               = SRV_TDS_BIT;
  SRVINT2              = SRV_TDS_INT2;
  SRVDECIMAL           = SRV_TDS_DECIMAL;
  SRVINT4              = SRV_TDS_INT4;
  SRVNUMERIC           = SRV_TDS_NUMERIC;
  SRVFLTN              = SRV_TDS_FLTN;
  SRVMONEYN            = SRV_TDS_MONEYN;
  SRVDATETIMN          = SRV_TDS_DATETIMN;



{ DB-Library datatypes (mainly taken from SQLfront.h) }
const
  DBMAXCHAR = 256;

  MAXNUMERICLEN = 16;
  MAXNUMERICDIG = 38;
  DEFAULTPRECISION = 18;
  DEFAULTSCALE = 0;

type
  DBCHAR = AnsiChar;
  PDBCHAR = PAnsiChar;
  DBBINARY = UInt8;
  DBTINYINT = UInt8;
  DBUSMALLINT = Int16;
  DBUSSMALLINT = UInt16;
  DBINT = Int32;
  DBFLT8 = double;
  DBBIT = UInt8;
  DBBOOL = UInt8;
  DBFLT4 = single;
  DBMONEY4 = Int32;
  DBMONEY = record
    mnyhigh: DBINT;
    mnylow: UInt32;
  end;
  DBDATETIM4 = record
         numdays: UInt16;   { No of days since Jan-1-1900    }
      nummins: UInt16;   { No. of minutes since midnight  }
  end;
  DBDATETIME = record
    dtdays: DBINT;      { number of days since 1/1/1900 }
    dttime: UInt32;     { number 300th second since mid }
  end;
  DBNUMERIC = record
    precision,
    scale: UInt8;
    sign: ByteBool;
    val: array[0..MAXNUMERICLEN] of Uint8;
  end;


{ Extended procedure error codes }
const
  SRV_MAXERROR = 20000;


{ srvapi.h }

function srv_describe(
           srvproc: PSRV_PROC;
           colnumber: integer;
           columnname: PDBCHAR;
           namelen: integer;
           desttype,
           destlen,
           srctype,
           srclen: DBINT;
           srcdata: pointer): integer; far; cdecl;

function srv_paramdata(
           srvproc: PSRV_PROC;
           n: integer): pointer; far; cdecl;

function srv_paramlen(
           srvproc: PSRV_PROC;
           n: integer): integer; far; cdecl;

function srv_parammaxlen(
           srvproc: PSRV_PROC;
           n: integer): integer; far; cdecl;

function srv_paramname(
           srvproc: PSRV_PROC;
           n: integer;
           len: integer): PDBCHAR; far; cdecl;

function srv_paramnumber(
           srvproc: PSRV_PROC;
           name: PDBCHAR;
           len: integer): integer; far; cdecl;

function srv_paramset(
           srvproc: PSRV_PROC;
           n: integer;
           data: pointer;
           len: integer): integer; far; cdecl;

function srv_paramstatus(
           srvproc: PSRV_PROC;
           n: integer): integer; far; cdecl;

function srv_paramtype(
           srvproc: PSRV_PROC;
           n: integer): integer; far; cdecl;

function srv_rpcparams(
           srvproc: PSRV_PROC): integer; far; cdecl;

function srv_senddone(
           srvproc: PSRV_PROC;
           status: DBUSMALLINT;
           curcmd: DBUSMALLINT;
           count: DBINT): integer; far; cdecl;

function srv_sendrow(
           srvproc: PSRV_PROC): integer; far; cdecl;

function srv_sendmsg(
           srvproc: PSRV_PROC;
           msgtype: integer;
           msgnum: DBINT;
           msgclass: DBTINYINT;
           state: DBTINYINT;
           rpcname: PDBCHAR;
           rpcnamelen: integer;
           linenum: DBUSMALLINT;
           message: PDBCHAR;
           msglen: integer): integer; far; cdecl;




{ the XP class }

const
  PARAM_ERROR = SRV_MAXERROR + 1;

type
  TSQLXProc = class
  protected
    srvproc: PSRV_PROC;
    ExpectedParamCount: integer;  { -1 = no check done }
    LastCol: cardinal;
    RowCount: cardinal;           { set to number of rows you return }
    function  GetParamCount: cardinal;
    function  GetParam(Index: integer): Variant;
    function  GetParamByName(Name: string): Variant;
    procedure SetParam(Index: integer; const Value: Variant);
    procedure SetParamByName(Name: string; const Value: Variant);
  public
    constructor Create(asrvproc: PSRV_PROC; AParamCount: integer);
    procedure DescribeColumn(const Name: string;
                             desttype, destlen,
                             srctype, srclen: integer;
                             srcdata:  pointer);
    function Execute: Boolean; virtual; abstract;
    function Run: SRVRETCODE;
    procedure SendRow;
    procedure SendErrorMsg(const Msg: string);
    procedure SendInfoMsg(const Msg: string);
    property ParamCount: cardinal read GetParamCount;
    property Params[Index: integer]: Variant read GetParam write SetParam;
    property ParamByName[Name: string]: Variant read GetParamByName write SetParamByName; default;
  end;



implementation

{$IFDEF Debug}
uses
  BBDebug;
{$ENDIF}


const
  opends = 'opends60.dll';


function srv_describe;       external opends name 'srv_describe';
function srv_paramdata;      external opends name 'srv_paramdata';
function srv_paramlen;       external opends name 'srv_paramlen';
function srv_parammaxlen;    external opends name 'srv_parammaxlen';
function srv_paramname;      external opends name 'srv_paramname';
function srv_paramnumber;    external opends name 'srv_paramnumber';
function srv_paramset;       external opends name 'srv_paramset';
function srv_paramstatus;    external opends name 'srv_paramstatus';
function srv_paramtype;      external opends name 'srv_paramtype';
function srv_rpcparams;      external opends name 'srv_rpcparams';
function srv_senddone;       external opends name 'srv_senddone';
function srv_sendrow;        external opends name 'srv_sendrow';
function srv_sendmsg;        external opends name 'srv_sendmsg';



{ TSQLXProc }

constructor TSQLXProc.Create(asrvproc: PSRV_PROC; AParamCount: integer);
begin
  inherited Create;
  srvproc := asrvproc;
  ExpectedParamCount := AParamCount;
end;


procedure TSQLXProc.DescribeColumn(
  const Name: string;
  desttype, destlen,
  srctype, srclen: integer;
  srcdata:  pointer);
begin
  LastCol := srv_describe(srvproc, LastCol+1, PChar(Name), SRV_NULLTERM,
                           desttype, destlen, srctype, srclen, srcdata);
  if LastCol = 0 then
    raise Exception.Create('srv_describe failed.');
end;


function TSQLXProc.GetParamCount: cardinal;
var
  params: integer;
begin
  params := srv_rpcparams(srvproc);
  if params < 0
    then  Result := 0
    else  Result := params;
end;


function TSQLXProc.GetParam(Index: integer): Variant;
var
  p: pointer;
  paramlen: integer;
  buf: array[0..DBMAXCHAR] of char;
  numeric: DBNUMERIC;
  l: longint;
  s: string;
  dbdt: dBDATETIME;
  dbdt4: dBDATETIM4;
  dt: TDateTime;
  money4: DBMONEY4;
  money: DBMONEY;
  dc: comp;
  dc2: comp;
begin
  p := srv_paramdata(srvproc, Index);
  if p = nil
    then  Result := Null
    else  begin
      paramlen := srv_paramlen(srvproc, Index);
{$IFDEF Debug}
      BBWrite('paramlen = ' + IntToStr(paramlen) + ' -- TSQLXProc.GetParam --');
{$ENDIF}
      case srv_paramtype(srvproc, Index) of
        SRVNULL: Result := Null;
        SRVVARCHAR,
        SRVCHAR:
          begin
            Move(p^, buf, paramlen);
            buf[paramlen] := #0;
            Result := StrPas(@buf);
          end;
        SRVINTN:
          begin
            case paramlen of
              1: Result := Int8(p^);
              2: Result := Int16(p^);
              4: Result := Int32(p^);
            end;
          end;
        SRVBIT: Result := ByteBool(p^);
        SRVDECIMAL,
        SRVNUMERIC:
          begin
            FillChar(numeric, 0, SizeOf(DBNUMERIC));
            Move(p^, numeric, paramlen);
            l := 0;
            Move(numeric.val, l, paramlen-3);
            s := IntToStr(l);
            System.Insert(DecimalSeparator, s, length(s) - numeric.scale + 1);
            Result := StrToFloat(s);
          end;
        SRVFLTN:
          begin
            if paramlen = 4
              then
                Result := single(p^)
              else
                Result := double(p^);
          end;
        SRVMONEYN:
          begin
            if paramlen = 4
              then  begin
                Move(p^, money4, paramlen);
                Result := money4 / 10000.0;
              end
              else  begin
                Move(p^, money, paramlen);
                dc := money.mnyhigh;
                dc := dc * $10000;
                dc := dc * $10000;
                if money.mnylow >= 0
                  then  dc2 := money.mnylow
                  else  begin
                    dc2 := $10000;
                    dc2 := dc2 * $10000;
                    dc2 := dc2 + money.mnylow;
                  end;
                dc := dc + dc2;
                Result := dc / 10000;
              end;
          end;
        SRVDATETIMN:
          begin
            if paramlen = 8
              then  begin
                Move(p^, dbdt, paramlen);
                dt := (dbdt.dtdays + 2) + (dbdt.dttime / (24*3600*300));
              end
              else  begin
                Move(p^, dbdt4, paramlen);
                dt := (dbdt4.numdays + 2) + (dbdt4.nummins / (24*60));
              end;
            Result := dt;
          end;
      else  begin
{$IFDEF Debug}
        BBWrite('srv_paramtype = ' + IntToStr(srv_paramtype(srvproc, Index)) + ' -- TSQLXProc.GetParam --');
{$ENDIF}
        Result := Null;
      end;
      end; { of case }
    end;
end;

function TSQLXProc.GetParamByName(Name: string): Variant;
var
  Index: integer;
begin
  Index := srv_paramnumber(srvproc,PChar(Name), SRV_NULLTERM);
  Result := GetParam(Index);
end;

function TSQLXProc.Run: SRVRETCODE;
var
  paramnum: integer;
  ResultOK: Boolean;
  s: string;
begin
{ Check number of parameters }
  paramnum := GetParamCount;
  if (ExpectedParamCount <> -1) and
     (paramnum <> ExpectedParamCount) then  begin
    { Send error message and return }
    srv_sendmsg(srvproc, SRV_MSG_ERROR, PARAM_ERROR, SRV_INFO, 0,
                nil, 0, 0, 'Error executing extended stored procedure: Invalid # of Parameters',
                SRV_NULLTERM);
    { A SRV_DONE_MORE instead of a SRV_DONE_FINAL must complete the
      result set of an Extended Stored Procedure. }
    srv_senddone(srvproc, (SRV_DONE_ERROR or SRV_DONE_MORE), 0, 0);
    Result := FAIL;
    Exit;
  end;

  try
    ResultOK := Execute;
  except
    on E:Exception do  begin
      ResultOK := False;
      s := 'Execution interrupted by exception: ' + E.Message;
      srv_sendmsg(srvproc, SRV_MSG_ERROR, 0, SRV_FATAL_PROCESS, 0, nil, 0, 0, PChar(s), SRV_NULLTERM);
    end;
  end;

{ send msg back depending on result }
  if ResultOK
    then  begin
      if RowCount > 0
        then
          srv_senddone(srvproc, SRV_DONE_COUNT or SRV_DONE_MORE, 0, RowCount)
        else
          srv_senddone(srvproc, SRV_DONE_MORE, 0, 0);
      Result := SUCCEED;
    end
    else  begin
      srv_senddone(srvproc, (SRV_DONE_ERROR or SRV_DONE_MORE), 0, 0);
      Result := FAIL;
    end;
end;


procedure TSQLXProc.SendErrorMsg(const Msg: string);
begin
  srv_sendmsg(srvproc, SRV_MSG_ERROR, 0, SRV_INFO, 0, nil, 0, 0, PChar(Msg), SRV_NULLTERM);
end;


procedure TSQLXProc.SendInfoMsg(const Msg: string);
begin
  srv_sendmsg(srvproc, SRV_MSG_INFO, 0, SRV_INFO, 0, nil, 0, 0, PChar(Msg), SRV_NULLTERM);
end;


procedure TSQLXProc.SetParam(Index: integer; const Value: Variant);

  function valsize(l: longint): integer;
  begin
    if l < $100
      then  Result := 1
      else  if l < $10000
      then  Result := 2
      else  if l < $1000000
      then  Result := 3
      else  Result := 4;
  end;

var
  dest: array[0..DBMAXCHAR] of AnsiChar;
  di: integer;
  ds: single;
  dd: double;
  parammaxlen: integer;
  s: string;
  l: longint;
  numeric: DBNUMERIC;
  p: word;
  b: ByteBool;
  dt: TDateTime;
  dbdt: DBDATETIME;
  dbdt4: DBDATETIM4;
  money4: DBMONEY4;
  money: DBMONEY;
  curint: comp;
  dc: comp;
begin
  parammaxlen := srv_parammaxlen(srvproc, Index);
{$IFDEF Debug}
  BBWrite('parammaxlen = ' + IntToStr(parammaxlen) + ' -- TSQLXProc.SetParam --');
{$ENDIF}
  if Value = Null
    then  begin
      srv_paramset(srvproc, Index, nil, 0);
    end
    else  begin
      case srv_paramtype(srvproc, Index) of
        SRVVARCHAR,
        SRVCHAR: srv_paramset(srvproc, Index, StrPCopy(dest, Value), length(Value));
        SRVINTN:
          begin
            di := Value;
            srv_paramset(srvproc, Index, @di, parammaxlen);
          end;
        SRVBIT:
          begin
            b := Value;
            srv_paramset(srvproc, Index, @b, SizeOf(ByteBool));
          end;
        SRVDECIMAL,
        SRVNUMERIC:
          begin
            s := FloatToStr(Value);
            p := Pos(DecimalSeparator, s);
            if p = 0 then  begin
              s:= s + DecimalSeparator + '0';
              p := Pos(DecimalSeparator, s);
            end;
            System.Delete(s, p, 1);
            l := StrToInt(s);
            FillChar(numeric, 0, SizeOf(DBNUMERIC));
            Move(l, numeric.val, SizeOf(l));
            numeric.sign := Value > 0;
            numeric.precision := length(s);
            numeric.scale := numeric.precision - p + 1;
            srv_paramset(srvproc, Index, @numeric, 3 + valsize(l));
          end;
        SRVFLTN:
          begin
            if parammaxlen = 4
              then  begin
                ds := Value;
                srv_paramset(srvproc, Index, @ds, SizeOf(ds));
              end
              else  begin
                dd := Value;
                srv_paramset(srvproc, Index, @dd, SizeOf(dd));
              end;
          end;
        SRVMONEYN:
          begin
            if parammaxlen = 4
              then  begin
                money4 := Value * 10000;
                srv_paramset(srvproc, Index, @money4, SizeOf(money4));
              end
              else  begin
                curint := Value * 10000;
                dc := curint / $10000;
                dc := dc / $10000;
                money.mnyhigh := Round(dc);
                dc := dc * $10000;
                dc := dc * $10000;
                money.mnylow := Round(curint - dc);
                if money.mnylow < 0 then
                  Dec(money.mnyhigh);
                srv_paramset(srvproc, Index, @money, SizeOf(money));
              end;
          end;
        SRVDATETIMN:
          begin
            dt := Value;
            if parammaxlen = 8
              then  begin
                dbdt.dtdays := Round(Int(dt)) - 2;
                dbdt.dttime := Round(Frac(dt) * (24*3600*300));
                srv_paramset(srvproc, Index, @dbdt, SizeOf(dbdt));
              end
              else  begin
                dbdt4.numdays := Round(Int(dt)) - 2;
                dbdt4.nummins := Round(Frac(dt) * (24*60));
                srv_paramset(srvproc, Index, @dbdt4, SizeOf(dbdt4));
              end;
          end;
      else  begin
        srv_paramset(srvproc, Index, nil, 0);
      {$IFDEF Debug}
        BBWrite('srv_paramtype = ' + IntToStr(srv_paramtype(srvproc, Index)) + ' -- TSQLXProc.SetParam');
      {$ENDIF}
      end;
      end; { of case }
    end;
end;


procedure TSQLXProc.SetParamByName(Name: string; const Value: Variant);
var
  Index: integer;
begin
  Index := srv_paramnumber(srvproc,PChar(Name), SRV_NULLTERM);
  SetParam(Index, Value);
end;


procedure TSQLXProc.SendRow;
begin
  if srv_sendrow(srvproc) = SUCCEED then
    Inc(RowCount);
end;


end.